00100	SUBTTL LISP INTERPRETER SUBROUTINES   --- PAGE 10
00200	
00300	CADADR:	SKIPA A,(A)
00400	CADAAR:	CAR A,(A)↔JRST CADAR
00500	CAAADR:	SKIPA A,(A)
00600	CAAAAR:	CAR A,(A)↔JRST CAAAR
00700	CAADDR:	SKIPA A,(A)
00800	CAADAR:	CAR A,(A)
00900	CAADR:	SKIPA A,(A)
01000	CAAAR:	CAR A,(A)↔JRST CAAR
01100	
01200	CADDDR:	SKIPA A,(A)
01300	CADDAR:	CAR A,(A)
01400	CADDR:	SKIPA A,(A)
01500	CADAR:	CAR A,(A)
01600	CADR:	SKIPA A,(A)
01700	CAAR:	CAR A,(A)
01800	CAR.:	CAR A,(A)↔POPJ P,
01900	
02000	CDDADR:	SKIPA A,(A)
02100	CDDAAR:	CAR A,(A)↔JRST CDDAR
02200	CDAADR:	SKIPA A,(A)
02300	CDAAAR:	CAR A,(A)↔JRST CDAAR
02400	CDADDR:	SKIPA A,(A)
02500	CDADAR:	CAR A,(A)
02600	CDADR:	SKIPA A,(A)
02700	CDAAR:	CAR A,(A)↔JRST CDAR
02800	
02900	CDDDDR:	SKIPA A,(A)
03000	CDDDAR:	CAR A,(A)
03100	CDDDR:	SKIPA A,(A)
03200	CDDAR:	CAR A,(A)
03300	CDDR:	SKIPA A,(A)
03400	CDAR:	CAR A,(A)
03500	CDR.:	CDR A,(A)↔POPJ P,
     

00100	
00200	QUOTE:	CAR A,(A)	;car and quote duplicated for backtrace
00300		POPJ P,
00400	
00500	AASCII:	PUSHJ P,NUMVAL
00600		LSH A,=29
00700		PUSHJ P,FWCONS
00800		PUSHJ P,NCONS
00900	PNGNK1:	PUSHJ P,NCONS
01000	FOO	MOVEI B,PNAME
01100		PUSHJ P,XCONS
01200	ACONS:	TROA B,-1
01300	NCONS:	TRZA B,-1
01400	XCONS:	EXCH B,A
01500	CONS:	AOS CONSVAL
01600		HRL B,A
01700		SKIPN A,F
01800		JRST [	HLR A,B
01900			PUSHJ P,AGC
02000			JRST .-1]
02100		LAC F,(F)
02200		DAC B,(A)
02300		POPJ P,
03300	
03400	PATOM:	CAML A,orgFWS
03500		JRST TRUE
03600		CAML A,orgHWS
03700	ATOM:	CAILE A,INUMIN
03800		JRST TRUE
03900		HLLE A,(A)
04000		AOJE A,TRUE
04100		JRST FALSE
     

00100	EQ:	CAMN A,B
00200		JRST TRUE
00300		JRST FALSE
00400	
00500	LENGTH:	MOVEI B,0
00600	LNGTH1:	CAILE A,INUMIN
00700		JRST FIX1
00800		HLLE C,(A)
00900		AOJE C,FIX1
01000		CDR A,(A)
01100		AOJA B,LNGTH1
01200	
01300	LAST:	CDR B,(A)
01400		CAILE B,INUMIN
01500		POPJ P,
01600		HLLE B,(B)
01700		AOJE B,CPOPJ
01800		CDR A,(A)
01900		JRST LAST
02000	
02100	DIP.:	EXCH A,B
02200	RPLACA:	DIP B,(A)
02300		POPJ P,
02400	
02500	DAP.:	EXCH A,B
02600	RPLACD:	DAP B,(A)
02700		POPJ P,
02800	
02900	ZEROP:	PUSHJ P,NUMVAL
03000	NOT:
03100	NULL:	JUMPN A,FALSE
03200	TRUE:
03300	FOO	MOVEI A,TRUTH
03400		POPJ P,
03500	
03600	FW0CNS:	MOVEI A,0
03700	FWCONS:	JUMPN FF,FWC1
03800		EXCH A,FWC0#
03900		PUSHJ P,AGC
04000		EXCH A,FWC0
04100	FWC1:	EXCH A,(FF)
04200		EXCH A,FF
04300		POPJ P,
04400	
     

00100	SASSOC:	PUSHJ P,SAS1
00200		JCALLF 0,(C)
00300		POPJ P,
00400	
00500	SAS0:	CAR B,T
00600	SAS1:	JUMPE B,CPOPJ
00700		MOVS T,(B)
00800		MOVS TT,(T)
00900		CAIE A,(TT)
01000		JRST SAS0
01100		CDR A,T
01200	CPOPJ1:	AOS (P)
01300		POPJ P,
01400	
01500	ASSOC:	PUSHJ P,SAS1
01600	FALSE:	MOVEI A,NIL
01700	CPOPJ:	POPJ P,
01800	
01900	REVERSE:	LAC T,A
02000		MOVEI A,0
02100		JUMPE T,CPOPJ
02200		CAR B,(T)
02300		CDR T,(T)
02400		PUSHJ P,XCONS
02500		JUMPN T,.-3
02600		POPJ P,
02700	
02800	
02900	REMPROP:	CDR T,(A)
03000		MOVS TT,(T)
03100		CAIN B,(TT)
03200		JRA TT,REMP1
03300		CAR A,TT
03400		CDR T,(A)
03500		JUMPN T,REMPROP+1
03600		JRST FALSE
03700	
03800	REMP1:	DAP TT,(A)
03900		JRST TRUE
     

00100	GET:	CDR A,(A)
00200		MOVS D,(A)
00300		CAIN B,(D)
00400		JRST CADR
00500		CAR A,D
00600		CDR A,(A)
00700		JUMPN A,GET+1
00800		POPJ P,
00900	
01000	GETL:	CDR A,(A)
01100	GETL0:	CAR T,(A)
01200		LAC C,B
01300	GETL1:	MOVS TT,(C)
01400		CAIN T,(TT)
01500		POPJ P,
01600		CAR C,TT
01700		JUMPN C,GETL1
01800		CDR A,(A)
01900		CDR A,(A)
02000		JUMPN A,GETL0
02100		POPJ P,
02200	
02300	NUMBERP:	CAILE A,INUMIN
02400		JRST TRUE
02500		HLLE T,(A)
02600		AOJN T,FALSE
02700		CDR A,(A)
02800		CAR A,(A)
02900	FOO	CAIE A,FIXNUM
03000	FOO	CAIN A,FLONUM
03100		JRST TRUE
03200	NUMBP2:	JRST FALSE	;bignums change this to JRST BIGNP
     

00100	PUTPROP:	LAC T,A
00200		CDR A,(A)
00300	CSET3:	MOVS TT,(A)
00400		CAR A,TT
00500		CAIN C,(TT)
00600		JRST CSET2
00700		CDR A,(A)
00800		JUMPN A,CSET3
00900		CDR A,(T)
01000		PUSHJ P,XCONS
01100		CDR B,C
01200		PUSHJ P,XCONS
01300		DAP A,(T)
01400		JRST CADR
01500	
01600	CSET2:
01700	FOO	CAIE C,VALUE
01800		JRST CSET1
01900		CDR T,(B)
02000		CAR A,(A)
02100		DAP T,(A)
02200		JRST PROG2
02300	
02400	CSET1:	DIP B,(A)
02500	PROG2:	LAC A,B
02600		POPJ P,
02700	
02800	DEFPROP:	
02900		CDR B,(A)
03000		CDR C,(B)
03100		CAR A,(A)
03200		CAR B,(B)
03300		CAR C,(C)
03400		PUSH P,A
03500		PUSHJ P,PUTPROP
03600		JRST POPAJ
     

00100	EQUAL:	LAC C,P
00200	EQUAL1:	CAMN A,B
00300		JRST TRUE
00400		LAC T,A
00500		LAC TT,B
00600		PUSHJ P,ATOM
00700		EXCH A,B
00800		PUSHJ P,ATOM
00900		CAMN A,B
01000		JRST EQUAL3
01100	EQUAL4:	LAC P,C
01200		JRST FALSE
01300	
01400	EQUAL3:	JUMPN A,EQ2
01500		PUSH P,T
01600		PUSH P,TT
01700		CAR A,(T)
01800		CAR B,(TT)
01900		PUSHJ P,EQUAL1
02000		JUMPE A,EQUAL4
02100		POP P,B
02200		POP P,A
02300		CDR A,(A)
02400		CDR B,(B)
02500		JRST EQUAL1
02600	
02700	EQ2:	PUSH P,T
02800		LAC A,T
02900		PUSHJ P,NUMBERP
03000		JUMPE A,EQUAL4
03100		LAC A,TT
03200		PUSHJ P,NUMBERP
03300		JUMPE A,EQUAL4
03400		LAC A,(P)
03500		DAC C,(P)
03600		LAC B,TT
03700		JSP C,OP
03800		JUMPL COMP3
03900		JUMPL COMP3
04000	
04100	COMP3:	POP P,C
04200		CAME A,TT
04300		JRST EQUAL4
04400		JRST TRUE
     

00100	SUBS5:	CDR A,SUBAS
00200		POPJ P,
00300	
00400	SUBST:	DAC A,SUBAS#
00500		DAC B,SUBBS#
00600	SUBS0A:	LAC A,SUBAS
00700		LAC B,SUBBS
00800		PUSH P,C
00900		LAC A,C
01000		PUSHJ P,EQUAL
01100		POP P,C
01200		JUMPN A,SUBS5
01300		CAILE C,INUMIN
01400		JRST EV6A
01500		HLLE T,(C)
01600		AOJN T,SUBS2
01700	EV6A:	LAC A,C
01800		POPJ P,
01900	
02000	SUBS2:	PUSH P,C
02100		CAR C,(C)
02200		PUSHJ P,SUBS0A
02300		EXCH A,(P)
02400		CDR C,(A)
02500		PUSHJ P,SUBS0A
02600		POP P,B
02700		JRST XCONS
     

00100	NCONC:	TDZA R,R
00200	APPEND:	MOVEI R,.APPEND-.NCONC
00300		JUMPE T,FALSE
00400		POP P,B
00500	APP2:	AOJE T,PROG2
00600		POP P,A
00700		PUSHJ P,.NCONC(R)
00800		LAC B,A
00900		JRST APP2
01000	
01100	.NCONC:	JUMPE A,PROG2
01200		LAC TT,A
01300		LAC C,TT
01400		CDR TT,(C)
01500		JUMPN TT,.-2
01600		DAP B,(C)
01700		POPJ P,
01800	
01900	.APPEND:	JUMPE A,PROG2
02000		MOVEI C,AR1
02100		LAC TT,A
02200	APP1:	CAR A,(TT)
02300		PUSH P,B
02400		PUSHJ P,CONS	;saves b
02500		POP P,B
02600		DAP A,(C)
02700		LAC C,A
02800		CDR TT,(TT)
02900		JUMPN TT,APP1
03000		JRST SUBS4
     

00100	MEMBER:	DAC A,SUBAS
00200	MEMB1:	JUMPE B,FALSE
00300		DAC B,SUBBS
00400		LAC A,SUBAS
00500		CAR B,(B)
00600		PUSHJ P,EQUAL
00700		JUMPN A,CPOPJ
00800		LAC B,SUBBS
00900		CDR B,(B)
01000		JRST MEMB1
01100	
01200	MEMQ:	JUMPE B,FALSE
01300		MOVS C,(B)
01400		CAIN A,(C)
01500		JRST TRUE
01600		CAR B,C
01700		JUMPN B,MEMQ+1
01800		JRST FALSE
01900	
02000	AND:
02100	FOO	HRLI A,TRUTH
02200	OR:	CAR C,A
02300		PUSH P,C
02400	ANDOR:	CDR C,A
02500		JUMPE C,AOEND
02600		MOVSI C,(<SKIPE (P)>)
02700		TLNE A,-1
02800		MOVSI C,(<SKIPN (P)>)
02900		XCT C
03000		JRST AOEND
03100		DAC A,(P)
03200		CAR A,(A)
03300		PUSHJ P,EVAL
03400		EXCH A,(P)
03500		HRR A,(A)
03600		JRST ANDOR
03700	
03800	AOEND:	POP P,A
03900		SKIPE A
04000	FOO	MOVEI A,TRUTH
04100		POPJ P,
     

00100	GENSYM:	LAC B,[POINT 7,GNUM,34]
00200		MOVNI C,4
00300		MOVEI TT,"0"
00400	
00500	GENSY2:	LDB T,B
00600		AOS T
00700		DPB T,B
00800		CAIG T,"9"
00900		JRST GENSY1
01000		DPB TT,B
01100		ADD B,[XWD 70000,0]
01200		AOJN C,GENSY2
01300	
01400	GENSY1:	LAC A,GNUM
01500		PUSHJ P,FWCONS
01600		PUSHJ P,NCONS
01700		JRST PNGNK1
01800	
01900	GNUM:	ASCII /G0000/			;*
02000	
02100	CSYM:	CAR A,(A)
02200		PUSH P,A
02300	FOO	MOVEI B,PNAME
02400		PUSHJ P,GET
02500		JUMPE A,NOPNAM
02600		CAR A,(A)
02700		LAC A,(A)
02800		DAC A,GNUM
02900		JRST POPAJ
     

00100	LIST:	LAC B,A
00200	FOO	MOVEI A,CEVAL
00300		JRST MAPCAR
00400	
00500	EELS:	CAR TT,(T)	;interpret lsubr call
00600		CDR A,(AR1)
00700	ILIST:	MOVEI T,0
00800		JUMPE A,ILIST2
00900	ILIST1:	PUSH P,A
01000		CAR A,(A)
01100		PUSH P,TT
01200		DIP T,(P)
01300		PUSHJ P,EVAL
01400	ILIST3:	POP P,TT
01500		HLRE T,TT
01600		EXCH A,(P)
01700		CDR A,(A)
01800		SOS T
01900		JUMPN A,ILIST1
02000	ILIST2:	JRST (TT)
02100	
02200	MAPC:	TLO A,400000
02300	MAP:	TLOA A,200000
02400	MAPCAR:	TLO A,400000
02500	MAPLIST:	JUMPE B,FALSE
02600		PUSH P,A
02700		PUSH P,B
02800		PUSH P,B
02900		DIPZ P,(P)
03000	MAPL2:	LAC A,-1(P)
03100		SKIPGE -2(P)
03200		CAR A,(A)
03300		CALLF 1,@-2(P)
03400		LDB C,[POINT 1,-2(P),1]
03500		JUMPN C,MAP1
03600		PUSHJ P,NCONS
03700		HLR B,(P)
03800		DAP A,(B)
03900		DIP A,(P)
04000	MAP1:	CDR B,@-1(P)
04100		DAC B,-1(P)
04200		JUMPN B,MAPL2
04300		POP P,AR1
04400		SUB P,[XWD 2,2]
04500	SUBS4:	CDR A,AR1
04600		POPJ P,0
     

00100	PA3:	0	;lh=0=>rh =next prog statement		*
00200		;lh - =>rh = tag to go to
00300	PA4:	0	;lh=-1,rh=pntr to prog less bound var list	*
00400		;lh=+,rh return value
00500		;2.1=>dont do unbnd
00600	
00700	PROG:	PUSH P,PA3
00800		PUSH P,PA4
00900		CAR TT,(A)
01000		CDR A,(A)
01100		HRROM A,PA4
01200		DAC A,PA3
01300		JUMPE TT,PG0
01400		MOVSI C,1
01500	FOO	MOVEI B,VALUE
01600		DAC SP,SPSV#
01700		ANDCAM C,PA4
01800	
01900	PG7A:	CAR A,(TT)
02000		MOVEI AR1,0
02100		PUSHJ P,BIND
02200		CDR TT,(TT)
02300		JUMPN TT,PG7A
02400		PUSH SP,SPSV
02500	
02600	PG0:	SKIPA T,PA3
02700	PG5A:	LAC T,A
02800	PG1:	JUMPE T,PG2
02900		CAR A,(T)
03000		CDR T,(T)
03100		HLLE B,(A)
03200		AOJE B,PG1
03300		DAC T,PA3
03400		PUSHJ P,EVAL
03500		SKIPL A,PA4
03600		JRST PG4	;return
03700		SKIPL T,PA3
03800		JRST PG1
03900	PG5:	JUMPE A,EG1
04000		CAR TT,(A)
04100		CDR A,(A)
04200		CAIN TT,(T)
04300		JRST PG5A	;found tag
04400		JRST PG5
04500	
04600	PG2:	TDZA A,A
04700	PG4:	HRRZS A
04800		MOVSI B,1
04900		TDNN B,PA4
05000		PUSHJ P,UNBIND
05100	ERRP4:	POP P,PA4
05200		POP P,PA3
05300		POPJ P,
05400	
05500	
05600	GO:	CAR A,(A)
05700		HRROM A,PA3
05800		HLLE B,(A)
05900		AOJE B,FALSE
06000		PUSHJ P,EVAL
06100		JRST GO+1
06200	
06300	
06400	RETURN:	HLL A,PA4
06500		TLZ A,-2
06600		DAC A,PA4
06700		POPJ P,
06800	
06900	SETQ:	CAR B,(A)
07000		PUSH P,B
07100		PUSHJ P,CADR
07200		PUSHJ P,EVAL
07300		LAC B,A
07400		POP P,A
07500	SET:	LAC AR1,B
07600		PUSHJ P,BIND
07700		SUB SP,[XWD 1,1]
07800		LAC A,AR1
07900		POPJ P,
08000	
08100	CON2:	CDR A,(T)
08200	COND:	JUMPE A,CPOPJ	;entry
08300		PUSH P,A
08400		CAR A,(A)
08500		CAR A,(A)
08600		PUSHJ P,EVAL
08700		POP P,T
08800		JUMPE A,CON2
08900		CAR T,(T)
09000	COND2:	CDR T,(T)
09100		JUMPE T,CPOPJ
09200		PUSH P,T
09300		CAR A,(T)
09400		PUSHJ P,EVAL
09500		POP P,T
09600		JRST COND2
     

00100	SUBTTL ARITHMETIC SUBROUTINES --- PAGE 11
00200	
00300	;macro expander -- (foo a b c) => (*foo (*foo a b) c)
00400	EXPAND:	LAC C,B
00500		CDR A,(A)
00600		PUSHJ P,REVERSE
00700		JRST EXPA1
00800	
00900	EXPN1:	LAC C,B
01000	EXPA1:	CDR T,(A)
01100		CAR A,(A)
01200		JUMPE T,CPOPJ
01300		PUSH P,A
01400		LAC A,T
01500		PUSHJ P,EXPA1
01600		EXCH A,(P)
01700		PUSHJ P,NCONS
01800		POP P,B
01900		PUSHJ P,XCONS
02000		LAC B,C
02100		JRST XCONS
02200	
     

00100	
00200	ADD1:	CAILE A,INUMIN
00300		CAIL A,-2
00400		SKIPA B,[INUM0+1]
00500		AOJA A,CPOPJ
00600	.PLUS:	JSP C,OP
00700		ADD A,TT
00800		FADR A,TT
00900	
01000	SUB1:	CAILE A,INUMIN+1
01100		SOJA A,CPOPJ
01200		MOVEI B,INUM0+1
01300	.DIF:	JSP C,OP
01400		SUB A,TT
01500		FSBR A,TT
01600	
01700	.TIMES:	JSP C,OP
01800		IMUL A,TT
01900		FMPR A,TT
02000	
02100	.QUO:	CAIN B,INUM0
02200		JRST ZERODIV
02300		JSP C,OP
02400		IDIV A,TT
02500		FDVR A,TT
02600	
02700	.GREAT:	EXCH A,B
02800		JUMPE B,FALSE
02900	.LESS:	JUMPE A,CPOPJ
03000		JSP C,OP
03100		JRST COMP2	;bignums know about me
03200		JRST COMP2
03300	
03400	COMP2:	CAML A,TT
03500		JRST FALSE
03600		JRST TRUE
     

00100	MAKNUM:
00200	FOO	CAIN B,FIXNUM
00300		JRST FIX1A
00400	FLO1A:
00500	FOO	MOVEI B,FLONUM
00600		PUSHJ P,FWCONS
00700		JRST ACONS-1
00800	
00900	FIX1B:	SUBI A,INUM0
01000	FOO	MOVEI B,FIXNUM
01100		PUSHJ P,FWCONS
01200		JRST ACONS-1
01300	
01400	NUMVLX:	JFCL 17,.+1
01500	NUMVAL:	CAIG A,INUMIN
01600		JRST NUMAG1
01700		SUBI A,INUM0
01800	FOO	MOVEI B,FIXNUM
01900		POPJ P,
02000	
02100	NUMAG1:	DAC A,AR1
02200		CDR A,(A)
02300		CAR B,(A)
02400		CDR A,(A)
02500	FOO	CAIE B,FIXNUM
02600	FOO	CAIN B,FLONUM
02700		SKIPA A,(A)
02800	NUMV4:	SKIPA A,AR1
02900		POPJ P,
03000	NUMV2:	PUSHJ P,EPRINT	;bignums know about me
03100		JRST NONNUM
03200	
03300	NUMV3:	JRST NONNUM		;bignums change me to JRST BIGDIS
     

00100	FLOAT:	IDIVI A,400000
00200		SKIPE A
00300		TLC A,254000
00400		TLC B,233000
00500		FADR A,B
00600		POPJ P,
00700	
00800	FIX:	PUSH P,A
00900		PUSHJ P,NUMVAL
01000	FOO	CAIE B,FLONUM
01100		JRST POPAJ
01200		MULI A,400
01300		TSC A,A
01400		JFCL 17,.+1
01500		ASH B,-243(A)
01600	FIX2:	JFCL 10,FIXOV	;bignums change me to jfcl 10,bfix
01700		POP P,A
01800	FIX1:	LAC A,B
01900		JRST FIX1A
02000	
02100	MINUSP:	PUSHJ P,NUMVAL
02200		JUMPGE A,FALSE
02300		JRST TRUE
02400	
02500	MINUS:	PUSHJ P,NUMVLX
02600		MOVNS A
02700		JFCL 10,@OPOV
02800		JRST MAKNUM
02900	
03000	ABS:	PUSHJ P,NUMVLX
03100		MOVMS A
03200		JRST MINUS+2
     

00100	DIVIDE:	CAIN B,INUM0
00200		JRST ZERODIV
00300		JSP C,OP
00400		JUMPN RDIV		;bignums know about me
00500		JRST ILLNUM
00600	RDIV:	IDIV A,TT
00700		PUSH P,B
00800		PUSHJ P,FIX1A
00900		EXCH A,(P)
01000		PUSHJ P,FIX1A
01100		POP P,B
01200		JRST XCONS
01300	
01400	REMAINDER:
01500		PUSHJ P,DIVIDE
01600		JRST CDR.
01700	
01800	FIXOV:	ERR1 [SIXBIT /INTEGER OVERFLOW!/]
01900	ZERODIV:ERR1 [SIXBIT /ZERO DIVISOR!/]
02000	FLOOV:	ERR1 [SIXBIT /FLOATING OVERFLOW!/]
02100	ILLNUM:	ERR1 [SIXBIT /NON-INTEGRAL OPERAND!/]
02200	
02300	GCD:	JSP C,OP
02400		JUMPA GCD2	;bignums know about me
02500		JRST ILLNUM
02600	GCD2:	MOVMS A
02700		MOVMS TT
02800	;euclid's algorithm
02900	GCD3:	CAMG A,TT
03000		EXCH A,TT
03100		JUMPE TT,FIX1A
03200		IDIV A,TT
03300		LAC A,B
03400		JRST GCD3
     

00100	;general arithmetic op code routine for mixed types
00200	
00300	OP:	CAIG A,INUMIN
00400		JRST OPA1
00500		SUBI A,INUM0
00600		CAIG B,INUMIN
00700		JRST OPA2
00800		HRREI TT,-INUM0(B)
00900		XCT (C)	;inum op  (cannot cause overflow)
01000	FIX1A:	ADDI A,INUM0
01100		CAILE A,INUMIN
01200		CAIL A,-1
01300		JRST FIX1B
01400		POPJ P,
01500	
01600	OPA1:	CDR A,(A)
01700		CAR T,(A)
01800		CDR A,(A)
01900	FOO	CAIE T,FIXNUM
02000		JRST OPA6
02100		SKIPA A,(A)
02200	OPA2:
02300	FOO	MOVEI T,FIXNUM
02400		CAILE B,INUMIN
02500		JRST OPB2
02600		CDR B,(B)
02700		CDR TT,(B)
02800		CAR B,(B)
02900	FOO	CAIE B,FIXNUM
03000		JRST OPA5
03100		SKIPA TT,(TT)
03200	OPB2:	HRREI TT,-INUM0(B)
03300		LAC AR1,A
03400		JFCL 17,.+1
03500		XCT (C)	;fixed pt op
03600	OPOV:	JFCL 10,FIXOV	;bignums change this to jfcl 10,fixovl
03700		JRST FIX1A
03800	
03900	OPA6:	CAILE B,INUMIN
04000		JRST OPB7
04100		CDR B,(B)
04200		CDR TT,(B)
04300		CAR B,(B)
04400	FOO	CAIE B,FLONUM
04500		JRST OPB3
04600	FOO	CAIE T,FLONUM
04700		JRST NUMV3
04800		LAC A,(A)
04900		LAC TT,(TT)
05000	OPR:	JFCL 17,.+1
05100		XCT 1(C)	;flt pt op
05200		JFCL 10,FLOOV
05300		JRST FLO1A
05400	
05500	OPA5:
05600	FOO	CAIE B,FLONUM
05700		JRST NUMV3
05800		PUSHJ P,FLOAT
05900		JRST OPR-1
06000	
06100	OPB3:
06200	FOO	CAIE B,FIXNUM
06300		JRST NUMV3
06400		SKIPA TT,(TT)
06500	OPB7:	HRREI TT,-INUM0(B)
06600	FOO	MOVEI B,FIXNUM
06700	FOO	CAIE T,FLONUM
06800		JRST NUMV3
06900		LAC A,(A)
07000		EXCH A,TT
07100		PUSHJ P,FLOAT
07200		EXCH A,TT
07300		JRST OPR
     

00100	SUBTTL EXPLODE, READLIST AND FRIENDS --- PAGE 12
00200	
00300	FLATSIZE:	HLLZS FLAT1
00400		MOVEI R,FLAT2
00500		PUSHJ P,PRINTA
00600	FLAT1:	MOVEI A,X			;*
00700		JRST FIX1A
00800	FLAT2:	AOS FLAT1
00900		POPJ P,
01000	
01100	
01200	%EXPLODE:	SKIPA R,.+1
01300	EXPLODE:	HRRZI R,EXPL1
01400		MOVSI AR1,AR1
01500		PUSHJ P,PRINTA
01600		JRST SUBS4
01700	
01800	EXPL1:	PUSH P,B
01900		PUSH P,C
02000		ANDI A,177
02100		CAIL A,"0"
02200		CAILE A,"9"
02300		JRST EXPL2
02400		ADDI A,INUM0-"0"
02500		JRST EXPL4
02600	
02700	EXPL2:	PUSH P,AR1
02800		PUSH P,TT
02900		PUSH P,T
03000		LSH A,35
03100		LAC C,SP
03200		PUSH C,A
03300		MOVEI AR1,1
03400		PUSHJ P,INTER0
03500		POP P,T
03600		POP P,TT
03700		POP P,AR1
03800	EXPL4:	PUSHJ P,NCONS
03900		HLR B,AR1
04000		DAP A,(B)
04100		DIP A,AR1
04200		POP P,C
04300		JRST POPBJ
     

00100	READLIST:	TDZA T,T
00200	MAKNAM:	MOVNI T,1
00300		DAC T,NOINFG
00400		PUSH P,OLDCH
00500		SETZM OLDCH
00600		JUMPE A,NOLIST
00700		DAP A,MKNAM3
00800		MOVEI A,MKNAM2
00900		PUSHJ P,READ0
01000		CDR T,MKNAM3
01100		CAIE T,-1
01200		JUMPN T,[ERR1 [SIXBIT /MORE THAN ONE S-EXPRESSION-MKNAM!/]]
01300		POP P,OLDCH
01400		POPJ P,
01500	
01600	MKNAM2:	PUSH P,B
01700		PUSH P,T
01800		PUSH P,TT
01900	MKNAM3:	MOVEI TT,X
02000		JUMPE TT,MKNAM6
02100		CAIN TT,-1
02200		ERR1 [SIXBIT /READ UNHAPPY-MAKNAM!/]
02300		CDR B,(TT)
02400		DAP B,MKNAM3
02500		CAR A,(TT)
02600		CAIGE A,INUMIN
02700		JRST MKNAM5
02800		SUBI A,INUM0-"0"
02900	MKNAM4:	POP P,TT
03000		POP P,T
03100		JRST POPBJ
03200	
03300	MKNAM5:	CAR A,(TT)
03400	FOO	MOVEI B,PNAME
03500		PUSHJ P,GET
03600		CAR A,(A)
03700		LDB A,[POINT 7,(A),6]
03800		JRST MKNAM4
03900	
04000	MKNAM6:	MOVEI A," "
04100		HLLOS MKNAM3
04200		JRST MKNAM4